home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 0669.ZIP / MENUS.PRG < prev    next >
Text File  |  1987-03-06  |  12KB  |  308 lines
  1. ****************************************************************************
  2. * The following demo shows how the function PROMPTER() can be used         *
  3. * instead of Clipper's built-in PROMPT/MESSAGE/MENU commands.              *
  4. * Advantages include:                                                      *
  5. *   - continuour wrap-around of the highlight bar                          *
  6. *   - no conflict with GET/READ since INKEY() is used (PROMPTER() only)    *
  7. *   - no conflict with function keys                                       *
  8. *   - F1 key can be reassigned while function is active                    *
  9. *   - horizontal prompts are easily spaced with one parameter              *
  10. *   - easy to change between horiz & vert prompting                        *
  11. *   - easy to change spacing between prompts                               *
  12. *                                                                          *
  13. * In this example, the user can also toggle between menu types             *
  14. * (highlighted prompts or numbered choices) by hitting F2.                 *
  15. *                                                                          *
  16. * The example uses Tom Rettig's external call CURSOR to turn the           *
  17. * cursor on and off; if you do not have TR.LIB, comment out the lines      *
  18. * which have the word CURSOR.  Otherwise, this file can be compiled and    *
  19. * linked as is.                                                            *
  20. *                                                                          *
  21. * Author:  C&E Consulting                                                  *
  22. *          6 Pebblecreek Court                                             *
  23. *          Taylors, SC 29687                                               *
  24. *          (803) 268-3341                                                  *
  25. *                                                                          *
  26. *          CompuServe - 76137,252                                          *
  27. *          The Source - NA2112                                             *
  28. *                                                                          *
  29. * Plug:    C&E Consulting provides custom program development in a         *
  30. *          variety of languages, as well as training and hardware          *
  31. *          recommendations.                                                *
  32. *                                                                          *
  33. *          Updates and other utilities can be obtained by sending          *
  34. *          an appropriate contribution to the address above.               *
  35. *                                                                          *
  36. *                                                                          *
  37. ****************************************************************************
  38.  
  39. * Initialize prompts and messages in arrays
  40.  
  41. DECLARE prompts[10],messages[10]
  42. prompts[1] ='One  '
  43. prompts[2] ='Two  '
  44. prompts[3] ='Three'
  45. prompts[4] ='Four '
  46. prompts[5] ='Five '
  47. prompts[6] ='Six  '
  48. prompts[7] ='Seven'
  49. prompts[8] ='Eight'
  50. prompts[9] ='Nine '
  51. prompts[10]='Ten  '
  52. FOR n=1 TO 10
  53.   messages[n]='Message for prompt '+STR(n,2)
  54. NEXT
  55. STORE .F. TO menu_num,menu_vert,mreset
  56. IF ISCOLOR()
  57.   color1='g/n,w/r'
  58.   color2='w/r'
  59. ELSE
  60.   color1='w/n,n/w'
  61.   color2='n/w'
  62. ENDIF
  63. SET COLOR TO &color1
  64.  
  65. ** DO SETFKEY WITH 1,'HELP'       && set F1 Key to Help
  66. DO SETFKEY WITH 2,'f_key2'        && set F2 Key to toggle menu types
  67. DO SETFKEY WITH 3,'f_key3'        && set F3 Key to toggle vert/horiz
  68.  
  69. CLEAR
  70. @ 1,0 SAY 'MENU SAMPLER - F2-bar/number  F3-vert/horiz  ESC-Quit'
  71. @ 2,0 SAY 'Copyright (c) 1987 C&E Consulting, Taylors, SC'
  72. DO WHILE .T.
  73.   @ 3,0 CLEAR TO 23,79
  74.   IF menu_vert
  75.     IF menu_num
  76.       maction=PROMPTNM(8,8,10)                       && vert numbered menus
  77.     ELSE
  78.       maction=PROMPTER(8,8,10,color1,color2,3)       && vert highlight menus
  79.     ENDIF
  80.   ELSE
  81.     IF menu_num
  82.       maction=PROMPTNM(8,0,10,.T.,10)                && horiz numbered menus
  83.     ELSE
  84.       maction=PROMPTER(8,0,10,color1,color2,3,.T.,7) && horiz highlight menus
  85.     ENDIF
  86.   ENDIF
  87.   IF mreset      && user has hit a menu toggle
  88.     mreset=.F.
  89.     LOOP
  90.   ENDIF
  91.   IF maction=0   && Esc or 0 key hit
  92.     CLEAR
  93.     QUIT
  94.   ENDIF
  95.   @ 24,0 SAY prompts[maction]+' chosen...' && result (put DO prgs here)
  96. ENDDO
  97.  
  98. PROCEDURE SETFKEY
  99.   * This procedure sets function keys - allows remapping by user
  100.   PARAMETER funckey,procname
  101.   PRIVATE fkey,fval
  102.   fval=IIF(-funckey+1=0,'28',STR(-funckey+1,2)) && translate Fkey# to Inkey#
  103.   fkey=LTRIM(STR(funckey,2))
  104.   IF TYPE("procname")="U"       && if procedure name not passed
  105.     f_key&fkey='Undefined'
  106.     SET KEY &fval TO
  107.   ELSE
  108.     f_key&fkey=procname
  109.     SET KEY &fval TO &procname
  110.   ENDIF
  111. RETURN
  112.  
  113. PROCEDURE f_key2     && Function key F2 toggles menu type
  114.   menu_num=IIF(menu_num=.T.,.F.,.T.)
  115.   mreset=.T.
  116.   KEYBOARD CHR(13)   && required to end prompting & switch to other menu
  117. RETURN
  118.  
  119. PROCEDURE f_key3     && Function key F3 toggles menu horiz or vert
  120.   menu_vert=IIF(menu_vert=.T.,.F.,.T.)
  121.   mreset=.T.
  122.   KEYBOARD CHR(13)   && required to end prompting & switch to other menu
  123. RETURN
  124.  
  125. FUNCTION PROMPTNM
  126.  
  127.   * menu requesting numbered choice rather than highlighted prompts
  128.   *
  129.   * Syntax: PROMPTNM(expN,expN,expN [,expL, expN])
  130.   * Assumptions: array prompts[] initialized
  131.   * Parameters:
  132.   *              begrow = beginning row for menu
  133.   *              begcol = beginning column for menu
  134.   *              opts   = number of menu options
  135.   *   Optional:
  136.   *              horiz  = true if prompts should be displayed horizontally
  137.   *              pspace = space from beginning of 1 prompt to next prompt
  138.   *                         (must not be zero!)
  139.   *
  140.   * Note: This version uses a GET/READ, and therefore is not as versatile
  141.   *       as PROMPTER(). INKEY() could be used if prompts are less than 10.
  142.   *       Also, if vertical prompts go beyond screen, pspace should be 
  143.   *       specified so prompts can go to another column.
  144.  
  145.   PARAMETERS begrow,begcol,opts,horiz,pspace
  146.   IF TYPE("msgln")='U'
  147.     msgln=-1
  148.   ENDIF
  149.   IF TYPE("pspace")='U'
  150.     pspace=1
  151.   ENDIF
  152.   IF TYPE("horiz")='U'
  153.     horiz=.F.
  154.   ENDIF
  155.   PRIVATE m_row,m_col,mperrow,most,minkey
  156.   PRIVATE x,opt_sel,mpict
  157.   CLEAR TYPEAHEAD
  158.   ** DO NUMLOCK WITH 'ON'   && optional - see ASMFILES.ARC on NPN
  159.   IF horiz
  160.     mperrow=(80-begcol)/pspace
  161.   ELSE
  162.     m_col=begcol
  163.   ENDIF
  164.   FOR x=1 TO opts
  165.     IF horiz
  166.       most=x % mperrow
  167.       m_row=begrow+IIF(most=0,(x-1)/mperrow,x/mperrow)
  168.       m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
  169.       @ m_row,m_col SAY STR(x,2)+'. '+prompts[x]
  170.     ELSE
  171.       @ begrow+(x-1)*pspace,begcol SAY STR(x,2)+'. '+prompts[x]
  172.     ENDIF
  173.   NEXT
  174.   mpict=IIF(opts<10,'9','99')
  175.   opt_sel=0
  176.   @ 23,0 SAY 'Enter Desired Selection ' GET opt_sel PICT mpict RANGE 0,opts
  177.   READ
  178.   ** DO NUMLOCK WITH 'OFF'  && optional - see ASMFILES.ARC on NPN
  179. RETURN(opt_sel)
  180.  
  181.  
  182.  
  183. FUNCTION PROMPTER
  184.  
  185.   * menu using highlighted prompts
  186.   *
  187.   * Syntax: PROMPTER(expN,expN,expN,expC,expC [,expN] [,expL] [expN])
  188.   * Assumptions: prompts[] array initialized, and
  189.   *              at least first 5 parameters passed
  190.   * Parameters:
  191.   *              begrow = beginning row for prompts
  192.   *              begcol = beginning column for prompts
  193.   *              opts   = number of promts
  194.   *              ncolor = normal color to use
  195.   *                         (cannot use Rettig's SCRATTR() if non-IBM bios)
  196.   *              hcolor = color to highlight prompts
  197.   *
  198.   *   Optional:
  199.   *              msgln  = -1 if no messages, else message line number
  200.   *                         if >=0, there must be a message for every prompt
  201.   *              horiz  = true if prompts should be displayed horizontally
  202.   *              pspace = space from beginning of 1 prompt to next prompt
  203.   *                         (must not be zero, required if many prompts)
  204.  
  205.   PARAMETERS begrow,begcol,opts,ncolor,hcolor,msgln,horiz,pspace
  206.   PRIVATE m_row,m_col,mperrow,most,x,minkey
  207.   DECLARE prmptbak[25],mesgbak[25]
  208.   ** DO NUMLOCK WITH 'off'      && optional - see ASMFILES.ARC on NPN
  209.   IF TYPE("msgln")='U'
  210.     msgln=-1
  211.   ENDIF
  212.   IF TYPE("horiz")='U'
  213.     horiz=.F.
  214.   ENDIF
  215.   IF TYPE("pspace")='U'
  216.     pspace=1
  217.   ENDIF
  218.   CALL CURSOR WITH 'off'        && Rettig call to turn cursor off
  219.   CLEAR TYPEAHEAD
  220.   IF horiz
  221.     mperrow=(80-begcol)/pspace
  222.   ELSE
  223.     m_col=begcol
  224.   ENDIF
  225.   FOR x=1 TO opts               && display choices in reverse video
  226.     IF horiz
  227.       most=x % mperrow
  228.       m_row=begrow+IIF(most=0,(x-1)/mperrow,x/mperrow)
  229.       m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
  230.       @ m_row,m_col SAY prompts[x]
  231.     ELSE
  232.       @ begrow+(x-1)*pspace,begcol SAY prompts[x]
  233.     ENDIF
  234.   NEXT
  235.   current=1
  236.   DO WHILE .T.
  237.     IF horiz
  238.       most=current % mperrow
  239.       m_row=begrow+IIF(most=0,(current-1)/mperrow,current/mperrow)
  240.       m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
  241.     ELSE
  242.       m_row=begrow+(current-1)*pspace
  243.     ENDIF
  244.     IF msgln<>-1
  245.       @ msgln,9 SAY messages[current]
  246.     ENDIF
  247.     SET COLOR TO &hcolor
  248.     @ m_row,m_col SAY prompts[current]
  249.     SET COLOR TO &ncolor
  250.     minkey=INKEY(0)
  251.     IF minkey<>13      && to stop screen flicker  (very minor)
  252.       @ m_row,m_col SAY prompts[current]    && unhighlight current selection
  253.     ENDIF
  254.     DO CASE
  255.       CASE minkey=5                              && up arrow
  256.         current=IIF(current-1>=1,current-1,opts)
  257.       CASE minkey=24                             && down arrow
  258.         current=IIF(current+1<=opts,current+1,1)
  259.       CASE minkey=4 .AND. horiz                  && right arrow
  260.         current=IIF(current<>opts,current+1,1)
  261.       CASE minkey=19 .AND. horiz                 && left  arrow
  262.         current=IIF(current<>1,current-1,opts)
  263.       CASE minkey=18 .OR. minkey=1               && PgUp or Home
  264.         current=1
  265.       CASE minkey=3 .OR. minkey=6                && PgDn or End
  266.         current=opts
  267.       CASE minkey=27                             && Escape
  268.         CALL CURSOR WITH 'ON'
  269.         RETURN(0)
  270.       CASE minkey=13                             && <CR> = selection
  271.         CALL CURSOR WITH 'ON'
  272.         RETURN(current)
  273.       CASE minkey<0 .OR. minkey=28               && Function keys
  274.         fknumber=IIF(minkey=28,28,ABS(minkey)+1)
  275.         fkname='f_key'+IIF(minkey=28,'1',LTRIM(STR(fknumber,2)))
  276.         function='&fkname'
  277.         FOR i=1 TO opts             &&  save prompts before calling
  278.           prmptbak[i]=prompts[i]    &&  in case the function does prompts
  279.           mesgbak[i]=messages[i]    &&  because they are global
  280.         NEXT
  281.         IF function='HELP'
  282.           ** DO HELP WITH PROCNAME(),PROCLINE(),READVAR()
  283.         ELSE
  284.           IF function<>'Undefined'
  285.             DO SETFKEY WITH fknumber           && turn off this function key
  286.             DO &function
  287.             DO SETFKEY WITH fknumber,function  && turn back on
  288.           ENDIF
  289.         ENDIF
  290.         FOR i=1 TO opts
  291.           prompts[i]=prmptbak[i]
  292.           messages[i]=mesgbak[i]
  293.         NEXT
  294.         CALL CURSOR WITH 'OFF'
  295.       OTHERWISE               && scan first letters of prompts for key hit
  296.         FOR x=1 TO opts
  297.           IF prompts[x]=UPPER(CHR(minkey))
  298.             CALL CURSOR WITH 'ON'
  299.             RETURN(x)
  300.           ENDIF
  301.         NEXT
  302.     ENDCASE
  303.   ENDDO
  304.  
  305.  
  306. ************* end of file **************************************************
  307.  
  308.